home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / calc202a.lha / calc-2.02a / calc-sel-2.el < prev    next >
Lisp/Scheme  |  1993-06-01  |  9KB  |  304 lines
  1. ;; Calculator for GNU Emacs, part II [calc-sel-2.el]
  2. ;; Copyright (C) 1990, 1991, 1992, 1993 Free Software Foundation, Inc.
  3. ;; Written by Dave Gillespie, daveg@synaptics.com.
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22.  
  23.  
  24. ;; This file is autoloaded from calc-ext.el.
  25. (require 'calc-ext)
  26.  
  27. (require 'calc-macs)
  28.  
  29. (defun calc-Need-calc-sel-2 () nil)
  30.  
  31.  
  32. (defun calc-commute-left (arg)
  33.   (interactive "p")
  34.   (if (< arg 0)
  35.       (calc-commute-right (- arg))
  36.     (calc-wrapper
  37.      (calc-preserve-point)
  38.      (let ((num (max 1 (calc-locate-cursor-element (point))))
  39.        (reselect calc-keep-selection))
  40.        (if (= arg 0) (setq arg nil))
  41.        (while (or (null arg) (>= (setq arg (1- arg)) 0))
  42.      (let* ((entry (calc-top num 'entry))
  43.         (expr (car entry))
  44.         (sel (calc-auto-selection entry))
  45.         parent new)
  46.        (or (and sel
  47.             (consp (setq parent (calc-find-assoc-parent-formula
  48.                      expr sel))))
  49.            (error "No term is selected"))
  50.        (if (and calc-assoc-selections
  51.             (assq (car parent) calc-assoc-ops))
  52.            (let ((outer (calc-find-parent-formula parent sel)))
  53.          (if (eq sel (nth 2 outer))
  54.              (setq new (calc-replace-sub-formula
  55.                 parent outer
  56.                 (cond
  57.                  ((memq (car outer)
  58.                     (nth 1 (assq (car-safe (nth 1 outer))
  59.                              calc-assoc-ops)))
  60.                   (let* ((other (nth 2 (nth 1 outer)))
  61.                      (new (calc-build-assoc-term
  62.                            (car (nth 1 outer))
  63.                            (calc-build-assoc-term
  64.                         (car outer)
  65.                         (nth 1 (nth 1 outer))
  66.                         sel)
  67.                            other)))
  68.                     (setq sel (nth 2 (nth 1 new)))
  69.                     new))
  70.                  ((eq (car outer) '-)
  71.                   (calc-build-assoc-term
  72.                    '+
  73.                    (setq sel (math-neg sel))
  74.                    (nth 1 outer)))
  75.                  ((eq (car outer) '/)
  76.                   (calc-build-assoc-term
  77.                    '*
  78.                    (setq sel (calcFunc-div 1 sel))
  79.                    (nth 1 outer)))
  80.                  (t (calc-build-assoc-term
  81.                      (car outer) sel (nth 1 outer))))))
  82.            (let ((next (calc-find-parent-formula parent outer)))
  83.              (if (not (and (consp next)
  84.                    (eq outer (nth 2 next))
  85.                    (eq (car next) (car outer))))
  86.              (setq new nil)
  87.                (setq new (calc-build-assoc-term
  88.                   (car next)
  89.                   sel
  90.                   (calc-build-assoc-term
  91.                    (car next) (nth 1 next) (nth 2 outer)))
  92.                  sel (nth 1 new)
  93.                  new (calc-replace-sub-formula
  94.                   parent next new))))))
  95.          (if (eq (nth 1 parent) sel)
  96.          (setq new nil)
  97.            (let ((p (nthcdr (1- (calc-find-sub-formula parent sel))
  98.                 (setq new (copy-sequence parent)))))
  99.          (setcar (cdr p) (car p))
  100.          (setcar p sel))))
  101.        (if (null new)
  102.            (if arg
  103.            (error "Term is already leftmost")
  104.          (or reselect
  105.              (calc-pop-push-list 1 (list expr) num '(nil)))
  106.          (setq arg 0))
  107.          (calc-pop-push-record-list
  108.           1 "left"
  109.           (list (calc-replace-sub-formula expr parent new))
  110.           num
  111.           (list (and (or (not (eq arg 0)) reselect)
  112.              sel)))))))))
  113. )
  114.  
  115. (defun calc-commute-right (arg)
  116.   (interactive "p")
  117.   (if (< arg 0)
  118.       (calc-commute-left (- arg))
  119.     (calc-wrapper
  120.      (calc-preserve-point)
  121.      (let ((num (max 1 (calc-locate-cursor-element (point))))
  122.        (reselect calc-keep-selection))
  123.        (if (= arg 0) (setq arg nil))
  124.        (while (or (null arg) (>= (setq arg (1- arg)) 0))
  125.      (let* ((entry (calc-top num 'entry))
  126.         (expr (car entry))
  127.         (sel (calc-auto-selection entry))
  128.         parent new)
  129.        (or (and sel
  130.             (consp (setq parent (calc-find-assoc-parent-formula
  131.                      expr sel))))
  132.            (error "No term is selected"))
  133.        (if (and calc-assoc-selections
  134.             (assq (car parent) calc-assoc-ops))
  135.            (let ((outer (calc-find-parent-formula parent sel)))
  136.          (if (eq sel (nth 1 outer))
  137.              (setq new (calc-replace-sub-formula
  138.                 parent outer
  139.                 (if (memq (car outer)
  140.                       (nth 2 (assq (car-safe (nth 2 outer))
  141.                                calc-assoc-ops)))
  142.                     (let ((other (nth 1 (nth 2 outer))))
  143.                       (calc-build-assoc-term
  144.                        (car outer)
  145.                        other
  146.                        (calc-build-assoc-term
  147.                     (car (nth 2 outer))
  148.                     sel
  149.                     (nth 2 (nth 2 outer)))))
  150.                   (let ((new (cond
  151.                           ((eq (car outer) '-)
  152.                            (calc-build-assoc-term
  153.                         '+
  154.                         (math-neg (nth 2 outer))
  155.                         sel))
  156.                           ((eq (car outer) '/)
  157.                            (calc-build-assoc-term
  158.                         '*
  159.                         (calcFunc-div 1 (nth 2 outer))
  160.                         sel))
  161.                           (t (calc-build-assoc-term
  162.                           (car outer)
  163.                           (nth 2 outer)
  164.                           sel)))))
  165.                     (setq sel (nth 2 new))
  166.                     new))))
  167.            (let ((next (calc-find-parent-formula parent outer)))
  168.              (if (not (and (consp next)
  169.                    (eq outer (nth 1 next))))
  170.              (setq new nil)
  171.                (setq new (calc-build-assoc-term
  172.                   (car outer)
  173.                   (calc-build-assoc-term
  174.                    (car next) (nth 1 outer) (nth 2 next))
  175.                   sel)
  176.                  sel (nth 2 new)
  177.                  new (calc-replace-sub-formula
  178.                   parent next new))))))
  179.          (if (eq (nth (1- (length parent)) parent) sel)
  180.          (setq new nil)
  181.            (let ((p (nthcdr (calc-find-sub-formula parent sel)
  182.                 (setq new (copy-sequence parent)))))
  183.          (setcar p (nth 1 p))
  184.          (setcar (cdr p) sel))))
  185.        (if (null new)
  186.            (if arg
  187.            (error "Term is already rightmost")
  188.          (or reselect
  189.              (calc-pop-push-list 1 (list expr) num '(nil)))
  190.          (setq arg 0))
  191.          (calc-pop-push-record-list
  192.           1 "rght"
  193.           (list (calc-replace-sub-formula expr parent new))
  194.           num
  195.           (list (and (or (not (eq arg 0)) reselect)
  196.              sel)))))))))
  197. )
  198.  
  199. (defun calc-build-assoc-term (op lhs rhs)
  200.   (cond ((and (eq op '+) (or (math-looks-negp rhs)
  201.                  (and (eq (car-safe rhs) 'cplx)
  202.                   (math-negp (nth 1 rhs))
  203.                   (eq (nth 2 rhs) 0))))
  204.      (list '- lhs (math-neg rhs)))
  205.     ((and (eq op '-) (or (math-looks-negp rhs)
  206.                  (and (eq (car-safe rhs) 'cplx)
  207.                   (math-negp (nth 1 rhs))
  208.                   (eq (nth 2 rhs) 0))))
  209.      (list '+ lhs (math-neg rhs)))
  210.     ((and (eq op '*) (and (eq (car-safe rhs) '/)
  211.                   (or (math-equal-int (nth 1 rhs) 1)
  212.                   (equal (nth 1 rhs) '(cplx 1 0)))))
  213.      (list '/ lhs (nth 2 rhs)))
  214.     ((and (eq op '/) (and (eq (car-safe rhs) '/)
  215.                   (or (math-equal-int (nth 1 rhs) 1)
  216.                   (equal (nth 1 rhs) '(cplx 1 0)))))
  217.      (list '/ lhs (nth 2 rhs)))
  218.     (t (list op lhs rhs)))
  219. )
  220.  
  221. (defun calc-sel-unpack ()
  222.   (interactive)
  223.   (calc-wrapper
  224.    (calc-preserve-point)
  225.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  226.       (reselect calc-keep-selection)
  227.       (entry (calc-top num 'entry))
  228.       (expr (car entry))
  229.       (sel (or (calc-auto-selection entry) expr)))
  230.      (or (and (not (math-primp sel))
  231.           (= (length sel) 2))
  232.      (error "Selection must be a function of one argument"))
  233.      (calc-pop-push-record-list 1 "unpk"
  234.                 (list (calc-replace-sub-formula
  235.                        expr sel (nth 1 sel)))
  236.                 num
  237.                 (list (and reselect (nth 1 sel))))))
  238. )
  239.  
  240. (defun calc-sel-isolate ()
  241.   (interactive)
  242.   (calc-slow-wrapper
  243.    (calc-preserve-point)
  244.    (let* ((num (max 1 (calc-locate-cursor-element (point))))
  245.       (reselect calc-keep-selection)
  246.       (entry (calc-top num 'entry))
  247.       (expr (car entry))
  248.       (sel (or (calc-auto-selection entry) (error "No selection")))
  249.       (eqn sel)
  250.       soln)
  251.      (while (and (or (consp (setq eqn (calc-find-parent-formula expr eqn)))
  252.              (error "Selection must be a member of an equation"))
  253.          (not (assq (car eqn) calc-tweak-eqn-table))))
  254.      (setq soln (math-solve-eqn eqn sel calc-hyperbolic-flag))
  255.      (or soln
  256.      (error "No solution found"))
  257.      (setq soln (calc-encase-atoms
  258.          (if (eq (not (calc-find-sub-formula (nth 2 eqn) sel))
  259.              (eq (nth 1 soln) sel))
  260.              soln
  261.            (list (nth 1 (assq (car soln) calc-tweak-eqn-table))
  262.              (nth 2 soln)
  263.              (nth 1 soln)))))
  264.      (calc-pop-push-record-list 1 "isol"
  265.                 (list (calc-replace-sub-formula
  266.                        expr eqn soln))
  267.                 num
  268.                 (list (and reselect sel)))
  269.      (calc-handle-whys)))
  270. )
  271.  
  272. (defun calc-sel-commute (many)
  273.   (interactive "P")
  274.   (let ((calc-assoc-selections nil))
  275.     (calc-rewrite-selection "CommuteRules" many "cmut"))
  276.   (calc-set-mode-line)
  277. )
  278.  
  279. (defun calc-sel-jump-equals (many)
  280.   (interactive "P")
  281.   (calc-rewrite-selection "JumpRules" many "jump")
  282. )
  283.  
  284. (defun calc-sel-distribute (many)
  285.   (interactive "P")
  286.   (calc-rewrite-selection "DistribRules" many "dist")
  287. )
  288.  
  289. (defun calc-sel-merge (many)
  290.   (interactive "P")
  291.   (calc-rewrite-selection "MergeRules" many "merg")
  292. )
  293.  
  294. (defun calc-sel-negate (many)
  295.   (interactive "P")
  296.   (calc-rewrite-selection "NegateRules" many "jneg")
  297. )
  298.  
  299. (defun calc-sel-invert (many)
  300.   (interactive "P")
  301.   (calc-rewrite-selection "InvertRules" many "jinv")
  302. )
  303.  
  304.